Clickx 115/Clickx 115.iso/software/tools/windows/tails-i386-0.16.iso/live/filesystem.squashfs/usr/share/tcltk/tcl8.5/tm.tcl

Text File | 2009-11-22 | 11.3 KB | 382 lines

# -*- tcl -*-
#
# Searching for Tcl Modules. Defines a procedure, declares it as the
# primary command for finding packages, however also uses the former
# 'package unknown' command as a fallback.
#
# Locates all possible packages in a directory via a less restricted
# glob. The targeted directory is derived from the name of the
# requested package. I.e. the TM scan will look only at directories
# which can contain the requested package. It will register all
# packages it found in the directory so that future requests have a
# higher chance of being fulfilled by the ifneeded database without
# having to come to us again.
#
# We do not remember where we have been and simply rescan targeted
# directories when invoked again. The reasoning is this:
#
# - The only way we get back to the same directory is if someone is
#   trying to [package require] something that wasn't there on the
#   first scan.
#
#   Either
#   1) It is there now:  If we rescan, you get it; if not you don't.
#
#      This covers the possibility that the application asked for a
#      package late, and the package was actually added to the
#      installation after the application was started. It shoukld
#      still be able to find it.
#
#   2) It still is not there: Either way, you don't get it, but the
#      rescan takes time. This is however an error case and we dont't
#      care that much about it
#
#   3) It was there the first time; but for some reason a "package
#      forget" has been run, and "package" doesn't know about it
#      anymore.
#
#      This can be an indication that the application wishes to reload
#      some functionality. And should work as well.
#
# Note that this also strikes a balance between doing a glob targeting
# a single package, and thus most likely requiring multiple globs of
# the same directory when the application is asking for many packages,
# and trying to glob for _everything_ in all subdirectories when
# looking for a package, which comes with a heavy startup cost.
#
# We scan for regular packages only if no satisfying module was found.

namespace eval ::tcl::tm {
    # Default paths. None yet.

    variable paths {/usr/share/tcltk/tcl8.5/tcl8}

    # The regex pattern a file name has to match to make it a Tcl Module.

    set pkgpattern {^([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)[.]tm$}

    # Export the public API

    namespace export path
    namespace ensemble create -command path -subcommand {add remove list}
}

# ::tcl::tm::path implementations --
#
#    Public API to the module path. See specification.
#
# Arguments
#    cmd -    The subcommand to execute
#    args -    The paths to add/remove. Must not appear querying the
#        path with 'list'.
#
# Results
#    No result for subcommands 'add' and 'remove'. A list of paths
#    for 'list'.
#
# Sideeffects
#    The subcommands 'add' and 'remove' manipulate the list of
#    paths to search for Tcl Modules. The subcommand 'list' has no
#    sideeffects.

proc ::tcl::tm::add {path args} {
    # PART OF THE ::tcl::tm::path ENSEMBLE
    #
    # The path is added at the head to the list of module paths.
    #
    # The command enforces the restriction that no path may be an
    # ancestor directory of any other path on the list. If the new
    # path violates this restriction an error wil be raised.
    #
    # If the path is already present as is no error will be raised and
    # no action will be taken.

    variable paths

    # We use a copy of the path as source during validation, and
    # extend it as well. Because we not only have to detect if the new
    # paths are bogus with respect to the existing paths, but also
    # between themselves. Otherwise we can still add bogus paths, by
    # specifying them in a single call. This makes the use of the new
    # paths simpler as well, a trivial assignment of the collected
    # paths to the official state var.

    set newpaths $paths
    foreach p [linsert $args 0 $path] {
    if {$p in $newpaths} {
        # Ignore a path already on the list.
        continue
    }

    # Search for paths which are subdirectories of the new one. If
    # there are any then the new path violates the restriction
    # about ancestors.

    set pos [lsearch -glob $newpaths ${p}/*]
    # Cannot use "in", we need the position for the message.
    if {$pos >= 0} {
        return -code error \
        "$p is ancestor of existing module path [lindex $newpaths $pos]."
    }

    # Now look for existing paths which are ancestors of the new
    # one. This reverse question forces us to loop over the
    # existing paths, as each element is the pattern, not the new
    # path :(

    foreach ep $newpaths {
        if {[string match ${ep}/* $p]} {
        return -code error \
            "$p is subdirectory of existing module path $ep."
        }
    }

    set newpaths [linsert $newpaths 0 $p]
    }

    # The validation of the input is complete and successful, and
    # everything in newpaths is either an old path, or added. We can
    # now extend the official list of paths, a simple assignment is
    # sufficient.

    set paths $newpaths
    return
}

proc ::tcl::tm::remove {path args} {
    # PART OF THE ::tcl::tm::path ENSEMBLE
    #
    # Removes the path from the list of module paths. The command is
    # silently ignored if the path is not on the list.

    variable paths

    foreach p [linsert $args 0 $path] {
    set pos [lsearch -exact $paths $p]
    if {$pos >= 0} {
        set paths [lreplace $paths $pos $pos]
    }
    }
}

proc ::tcl::tm::list {} {
    # PART OF THE ::tcl::tm::path ENSEMBLE

    variable paths
    return  $paths
}

# ::tcl::tm::UnknownHandler --
#
#    Unknown handler for Tcl Modules, i.e. packages in module form.
#
# Arguments
#    original    - Original [package unknown] procedure.
#    name        - Name of desired package.
#    version        - Version of desired package. Can be the
#              empty string.
#    exact        - Either -exact or ommitted.
#
#    Name, version, and exact are used to determine
#    satisfaction. The original is called iff no satisfaction was
#    achieved. The name is also used to compute the directory to
#    target in the search.
#
# Results
#    None.
#
# Sideeffects
#    May populate the package ifneeded database with additional
#    provide scripts.

proc ::tcl::tm::UnknownHandler {original name args} {
    # Import the list of paths to search for packages in module form.
    # Import the pattern used to check package names in detail.

    variable paths
    variable pkgpattern

    # Without paths to search we can do nothing. (Except falling back
    # to the regular search).

    if {[llength $paths]} {
    set pkgpath [string map {:: /} $name]
    set pkgroot [file dirname $pkgpath]
    if {$pkgroot eq "."} {
        set pkgroot ""
    }

    # We don't remember a copy of the paths while looping. Tcl
    # Modules are unable to change the list while we are searching
    # for them. This also simplifies the loop, as we cannot get
    # additional directories while iterating over the list. A
    # simple foreach is sufficient.

    set satisfied 0
    foreach path $paths {
        if {![interp issafe] && ![file exists $path]} {
        continue
        }
        set currentsearchpath [file join $path $pkgroot]
        if {![interp issafe] && ![file exists $currentsearchpath]} {
        continue
        }
        set strip [llength [file split $path]]

        # We can't use glob in safe interps, so enclose the following
        # in a catch statement, where we get the module files out
        # of the subdirectories. In other words, Tcl Modules are
        # not-functional in such an interpreter. This is the same
        # as for the command "tclPkgUnknown", i.e. the search for
        # regular packages.

        catch {
        # We always look for _all_ possible modules in the current
        # path, to get the max result out of the glob.

        foreach file [glob -nocomplain -directory $currentsearchpath *.tm] {
            set pkgfilename [join [lrange [file split $file] $strip end] ::]

            if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} {
            # Ignore everything not matching our pattern
            # for package names.
            continue
            }
            if {[catch {package vcompare $pkgversion 0}]} {
            # Ignore everything where the version part is
            # not acceptable to "package vcompare".
            continue
            }

            # We have found a candidate, generate a "provide
            # script" for it, and remember it.  Note that we
            # are using ::list to do this; locally [list]
            # means something else without the namespace
            # specifier.

            # NOTE. When making changes to the format of the
            # provide command generated below CHECK that the
            # 'LOCATE' procedure in core file
            # 'platform/shell.tcl' still understands it, or,
            # if not, update its implementation appropriately.
            #
            # Right now LOCATE's implementation assumes that
            # the path of the package file is the last element
            # in the list.

            package ifneeded $pkgname $pkgversion \
            "[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]"

            # We abort in this unknown handler only if we got
            # a satisfying candidate for the requested
            # package. Otherwise we still have to fallback to
            # the regular package search to complete the
            # processing.

            if {
            ($pkgname eq $name) &&
            [package vsatisfies $pkgversion {*}$args]
            } then {
            set satisfied 1
            # We do not abort the loop, and keep adding
            # provide scripts for every candidate in the
            # directory, just remember to not fall back to
            # the regular search anymore.
            }
        }
        }
    }

    if {$satisfied} {
        return
    }
    }

    # Fallback to previous command, if existing.  See comment above
    # about ::list...

    if {[llength $original]} {
    uplevel 1 $original [::linsert $args 0 $name]
    }
}

# ::tcl::tm::Defaults --
#
#    Determines the default search paths.
#
# Arguments
#    None
#
# Results
#    None.
#
# Sideeffects
#    May add paths to the list of defaults.

proc ::tcl::tm::Defaults {} {
    global env tcl_platform

    lassign [split [info tclversion] .] major minor
    set exe [file normalize [info nameofexecutable]]

    # Note that we're using [::list], not [list] because [list] means
    # something other than [::list] in this namespace.
    roots [::list \
        [file dirname [info library]] \
        [file join [file dirname [file dirname $exe]] lib] \
        ]

    if {$tcl_platform(platform) eq "windows"} {
    set sep ";"
    } else {
    set sep ":"
    }
    for {set n $minor} {$n >= 0} {incr n -1} {
    foreach ev [::list \
            TCL${major}.${n}_TM_PATH \
            TCL${major}_${n}_TM_PATH \
        ] {
        if {![info exists env($ev)]} continue
        foreach p [split $env($ev) $sep] {
        path add $p
        }
    }
    }
    return
}

# ::tcl::tm::roots --
#
#    Public API to the module path. See specification.
#
# Arguments
#    paths -    List of 'root' paths to derive search paths from.
#
# Results
#    No result.
#
# Sideeffects
#    Calls 'path add' to paths to the list of module search paths.

proc ::tcl::tm::roots {paths} {
    foreach {major minor} [split [info tclversion] .] break
    foreach pa $paths {
    set p [file join $pa tcl$major]
    for {set n $minor} {$n >= 0} {incr n -1} {
        set px [file join $p ${major}.${n}]
        if {![interp issafe]} { set px [file normalize $px] }
        path add $px
    }
    set px [file join $p site-tcl]
    if {![interp issafe]} { set px [file normalize $px] }
    path add $px
    }
    return
}

# Initialization. Set up the default paths, then insert the new
# handler into the chain.

if {![interp issafe]} { ::tcl::tm::Defaults }
if {![interp issafe]} { ::tcl::tm::roots {/usr/lib/tcltk /usr/share/tcltk} }